perm filename GEMTXT[G,BGB] blob
sn#077828 filedate 1974-01-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00024 PAGES
C REC PAGE DESCRIPTION
C00001 00001 VALID 00019 PAGES
C00003 00002 TITLE GEMTXT - TEXT ROUTINES FOR GEOMETRIC MODELING.
C00005 00003 SUBR(KLTEXT,NODE)
C00008 00004 SUBR(SETEXT,NODE,SUBRLOC)
C00012 00005 SUBR(EDTEXT,NODE)
C00014 00006 ----- EDTEXT COMMAND TABLES
C00016 00007 ----- EDTEXT COMMAND ROUTINES
C00019 00008 SUBR EDSYS,NODE,CHAR Invoke system line editor
C00025 00009 SUBR(EDDPY,NODE,CURCHR)
C00027 00010 SUBR(INSTXT,NODE)
C00029 00011 SUBR(NXTLIN,NODE)
C00032 00012 SUBR(YDPY,NODE)
C00035 00013 SUBR(DPYARW,NODE)
C00040 00014 ---- DPYARW continued.
C00042 00015 ARROW PARAMETERS:
C00043 00016 SUBR(EXTARW,NODE,CAMERA)
C00046 00017 ---- EXTARW continued.
C00048 00018 Arrow Extension Mandala
C00050 00019 SUBR(APROJ,VERTEX,CAMERA) TRANSLATE VERTEX TO CAMERA LOCUS.
C00052 00020 Subroutines WREFLO,WRFFLO,WRFLO
C00054 00021 +X.XXXE+YY
C00056 00022 FLOST: ADDI CHRCNT,4
C00059 00023 FLOATING POINT NORMALIZE (FOR BASE 10).
C00062 00024 OUTPUT FLOATING POINT NUMBER IN SPECIFIED FORMAT
C00065 ENDMK
C⊗;
TITLE GEMTXT - TEXT ROUTINES FOR GEOMETRIC MODELING.
EXTERN META,CTRL,GETCHW,PLTFLG,FACOEF,RVECT
EXTERN DPYBUF,AIVECT,IFORM2,GEODPY,DPYOUT,DPYBIG,DPYSET,NEWMAC
EXTERN DTYO,DPYSTR
EXTERN SOX,SOY,MAG,XL,YL,YH
DECLARE{TX,TY}
SUBR(MKY,VERTEX,TYPREL) ;MAKE Y-NODE.
COMMENT ⊗____________________________________________________________
⊗↔ CALL(MKNODE↑,[$YNODE])
LAC TYPREL↔DAC YREL(1) ;SETUP RELLOCATION.
PUSHP 2↔LAC 2,VERTEX
LOOP: PY 0,2↔JUMPE 0,[
PY. 1,2↔NY. 2,1
POPP 2↔POP2J]
LAC 2,0
GO LOOP
ENDR MKY;------------------------------------------------------------
SUBR(KLY,NODE)
COMMENT ⊗____________________________________________________________
⊗↔ LAC 1,NODE
PUSHP 2↔PUSHP 3
PY 2,1↔NY 2,1
PY. 3,2↔SKIPE 3↔NY. 2,3
CALL(KLNODE↑,1)
LAC 1,3
POPP 3↔POPP 2
POP1J
ENDR KLY;____________________________________________________________
SUBR(KLTEXT,NODE)
COMMENT ⊗____________________________________________________________
If called with vertex, all text on that vertex is deleted.
If called with a text node, only that line is deleted.
Returns previous node.
Uses AC 0-1, Transparent wrt to other AC's. ⊗
ACCUMULATORS{LAST,NEXT}
LAC 1,NODE
TEST 1,VBIT
GO KLLINE
PTEXT 1,1 ;Get text pointer
JUMPE 1,POP1J. ;None there
TESTZ 1,VBIT ;Is it a vertex?
POP1J ;Oops, a TJOINT, return
PUSHP NEXT
VLOOP: TCCW NEXT,1 ;Save pointer to next node
CALL(KLNODE,1) ;Kill a text node
LAC 1,NEXT ;Get back pointer to next node
JUMPN 1,VLOOP ;Repeat until NIL is found.
POPP NEXT
POP1J
KLLINE: PUSHP LAST↔PUSHP NEXT ;Save old LAST and NEXT
TCW LAST,1 ;Save pointer to LAST
KLLOOP: TCCW NEXT,1 ;Save pointer to NEXT
TEST 1,CONBIT ;Last in line?
GO LAST1 ;Yes
CALL(KLNODE,1) ;Kill this node
LAC 1,NEXT ;Get back pointer to next node
GO KLLOOP ;Repeat for rest of line
LAST1: CALL(KLNODE,1) ;Kill last node in line
TESTZ LAST,VBIT ;Is previous a vertex.?
GO [ PTEXT. NEXT,LAST ;Yes, use a different pointer
GO LAST2 ]
TCCW. NEXT,LAST ;New forward link
LAST2: JUMPE NEXT,LAST3 ;Don't try to store into NIL!
TCW. LAST,NEXT ;New backward link
LAST3: LAC 1,LAST
POPP LAST↔POPP NEXT ;Restore AC 2 and 3
POP1J
ENDR KLTEXT;5/4/73(TVR)----------------------------------------------
SUBR(SETEXT,NODE,SUBRLOC)
COMMENT ⊗____________________________________________________________
Called with a text node and the address of a subroutine which
fetches a character and skips if successful, with character in AC.1.
SETEXT returns on failure from character fetching subroutine or when
a <line feed> or <alt mode> is seen. Leaves terminating character
in AC.1. Uses AC 0-3. Calls KLTEXT. ⊗
ACCUMULATORS {PTR,N}
LAC N,NODE
NDLOOP: CALL SETPTR ;Set up count and byte pointer
CHLOOP: PUSHJ P,@SUBRLOC ;Call character fetching routine
GO CHDONE ;Failure return
JUMPE 1,CHLOOP ;Ignore nulls for now
CAIN 1,15 ;CROCKISHNESS!!!
GO CHLOOP
CAIE 1,12 ;Terminate in <line feed>
CAIN 1,175 ;or <alt mode>
GO CHDONE
SOJGE 0,DEPCHR ;Make sure it fits
TESTZ N,CONBIT ;Need another block
GO [ TCCW N,N ;This line already has one, use it
GO GOTNODE ]
PUSHP 1 ;Save character over MKNODE
TCCW PTR,N ;Get next node
CALL(MKNODE↑,[$TEXT]) ;Make a new text node
TCCW. PTR,1 ;Make new forward links
TCCW. 1,N
TCW. N,1 ;Make new backward links
SKIPE PTR↔TCW. 1,PTR ;Don't store into NIL
MARK N,CONBIT ;Turn on bit indication this is continued
LAC N,1 ;Now use this node
POPP 1 ;Get back character
GOTNOD: CALL SETPTR ;Set up count and byte pointer
DEPCHR: IDPB 1,PTR ;Deposit character into text node
GO CHLOOP ;Back for more
CHDONE: PUSHP 1 ;Save terminator
SETZ 1, ;Fill remainder of node with nulls
ZPLOOP: SOJGE 0,[ IDPB 1,PTR
GO ZPLOOP]
TEST N,CONBIT ;Is there more on this line?
GO FIN
MARKZ N,CONBIT ;Turn off bit indicating more in line
TCCW N,N ;Get next node
CALL(KLTEXT,N) ;Kill rest of line
FIN: POPP 1 ;Get terminating character
POP2J ;Return
SETPTR: LAC PTR,N ;Make byte pointer to word number 1
HRLI PTR,000700
MOVEI 0,5*8-1 ;Number of characters per node
POPJ P,
ENDR SETEXT;4-MAY-73(TVR)____________________________________________
SUBR(EDTEXT,NODE)
COMMENT ⊗------------------------------------------------------------
⊗↔ ACCUMULATORS{T1,T2,T3,COUNT,SIGN,CHAR,N}
LAC N,NODE
TESTZ N,VBIT↔PY N,N
JUMPE N,[ CALL (MKY,NODE,[.RLTXT])
MARK 1,VBIT
LAC N,NODE
HRLZI 0,XWC(N) ;COPY CO-ORDINATES
HRRI 0,XWC(1)
BLT 0,ZWC(1)
LAC N,1 ;SET SIZE TO 1
LACI 0,1
DPSIZ. 0,N
GO NEWTXT ]
SETOM EDUPDATE
SETZM ENDFLG
TESTZ N,VBIT↔PTEXT N,N
LOOP0: SETZ CHAR,
LOOP: CALL(EDDPY,N,["→"])
SETZB COUNT,SIGN
SKIPN CHAR
LOOP2: GO [ CALL(GETCHW)
LAC CHAR,1
GO .+1 ]
CAIN CHAR,15↔GO LOOP2
LDB 1,[POINT 2,CHAR,35-7]
LAC T1,CTABS(1)
LAC T2,CHAR↔ANDI T2,177
CAIL T2,"0"↔CAIL T2,"9"↔GO NOTNUM
TRNN CHAR,200↔GO NOTNUM
IMULI COUNT,=10
ADDI COUNT,-"0"(T2)
GO LOOP2
NOTNUM: CAIL T2,"a"↔CAILE T2,"z"↔GO LOOP3
SUBI T2,40
LOOP3: CAR 0,(T1)
CAIE 0,(T2)↔AOBJN T1,LOOP3
CAIE 0,(T2)
GO [ TRNN CHAR,200↔GO LINED
UNKNOWN: OUTSTR[ASCIZ/Unknown command: /]
TRNE CHAR,200↔OUTSTR[ASCIZ/<control>/]
TRNE CHAR,400↔OUTSTR[ASCIZ/<meta>/]
OUTCHR CHAR↔GO LOOP0 ]
CDR T2,(T1)
GO(T2)
;----- EDTEXT ;COMMAND TABLES
CTABS: FOR @` I←0,3,1
< XWD -CLEN`I,CTAB`I
>
CTAB0: XWD 12,[MOVEI 0,1↔GO MOVER]
XWD 177,[MOVNI 0,1↔GO MOVER]
XWD 13,[MOVNI 0,1↔GO MOVER]
XWD 175,LOOP0
CLEN0←←.-CTAB0
CTAB1:
;Commands to system line editor (includes <space> and <tab>:
FOR I ε {DIKS }
< XWD "I",LINED
>
XWD 12,[MOVEI 0,1↔GO MOVER]
CTAB3: XWD 13,[MOVNI 0,1↔GO MOVER] ;VT
XWD "<",[MOVNI 0,4↔GO MOVER]
XWD ">",[MOVEI 0,4↔GO MOVER]
XWD "≤",[MOVNI 0,16↔GO MOVER]
XWD "≥",[MOVEI 0,16↔GO MOVER]
XWD "↑",[MOVNI 0,1↔MOVEI CHAR,211↔GO MOVER2]
XWD "↓",[MOVEI 0,1↔MOVEI CHAR,211↔GO MOVER2]
XWD "Q",[TCW 1,N↔TESTZ 1,VBIT↔GO LOOP0
SETZ CHAR,↔CALL(EDSYS+1,N,CHAR)
GO LOOP]
XWD "/",CHGSIZ ;SHRINK DPY CHR SIZE.
XWD "\",CHGSIZ ;EXPAND DPY CHR SIZE.
XWD "V",UPGEO ;REFRESH.
XWD "Z",JOIN
XWD "+",[MOVEI SIGN,1↔GO LOOP2]
XWD "-",[SKIPN SIGN↔MOVEI SIGN,1
MOVN SIGN,SIGN↔GO LOOP2]
XWD "E",[EDEXIT: PGIOT 2,↔POP1J]
XWD "M",[SETZM CTRL↔SETZM META
CALL(NEWMAC)↔GO LOOP0]
XWD "N",[SETZM CTRL↔SETZM META
CALL(IFORM2)↔GO LOOP0]
CLEN1←←.-CTAB1
XWD 12,INSLIN
XWD "I",INSLIN
XWD "D",DELLIN
CLEN3←←.-CTAB3
CTAB2: XWD 12,UNKNOWN
CLEN2←←.-CTAB2
;----- EDTEXT ;COMMAND ROUTINES
MOVER: SETZ CHAR,
MOVER2: SKIPN COUNT
MOVEI COUNT,1
IMUL COUNT,0
SKIPGE SIGN
MOVN COUNT,COUNT
JUMPL COUNT,BACK
SETZM ENDFLG
FORWRD: CALL NXTLIN,N
JUMPE 1,[SETOM ENDFLG
GO LOOP]
LAC N,1
SOJG COUNT,FORWRD
GO LOOP
BACK: SKIPE ENDFLG
GO [ SETZM ENDFLG
GO BACK2 ]
BACK1: CALL PRVLIN,N
TESTZ 1,VBIT
GO LOOP
LAC N,1
BACK2: AOJL COUNT,BACK1
GO LOOP
LINED: SKIPE ENDFLG
GO [ CAIL CHAR,177
GO UNKNOWN
CALL(INSTXT,N)
LAC N,1
SETZM ENDFLG
GO LINED ]
CALL EDSYS,N,CHAR
DAC 1,CHAR
GO LOOP
INSLIN: TCW N,N
JUMPG COUNT,INSLI2
NEWTXT: CALL(INSTXT,N)
DAC 1,N
CALL(EDDPY,N,["↔"])
SETZM CLRLIN
CALL(EDSYS,N,[0])
CAIN 1,12
GO NEWTXT
GO LOOP0
INSLI2: CALL(INSTXT,N)
SOJG COUNT,INSLI2
CALL(PRVLIN,N)
GO LOOP0
DELLIN: SKIPE ENDFLG
GO LOOP0
SKIPE SIGN
IMULI COUNT,SIGN
JUMPL COUNT,DBACK
DELLI2: CALL(KLTEXT,N)
LAC N,1
TESTZ N,VBIT
GO [ PTEXT 1,N
GO DELLI3 ]
TCCW 1,N
DELLI3: JUMPE 1,[ TESTZ N,VBIT
GO [ OUTSTR[ASCIZ/NOTHING LEFT!/]
GO EDEXIT ]
SETOM ENDFLG
GO LOOP0 ]
LAC N,1
SOJG COUNT,DELLI2
GO LOOP0
DBACK: CALL(KLTEXT,N)
LAC N,1
TESTZ N,VBIT
GO [ PTEXT N,N
JUMPE N,[ OUTSTR[ASCIZ/NOTHING LEFT!/]
GO EDEXIT ]
GO LOOP0 ]
TLNE 0,(CONBIT)
SUBI COUNT,1
DBACK2: AOJL COUNT,DBACK
GO LOOP0
JOIN: CALL(NXTLIN,N)
JUMPE 1,LOOP0
TCW 1,1
MARK 1,CONBIT
GO LOOP0
CHGSIZ: LAC 1,N
TEST 1,VBIT
GO [ TCW 1,1
GO CHGSIZ+1 ]
DPSIZ 0,1
CAIE CHAR,200+"/"
CAIN CHAR,600+"/"
SUBI 0,1
CAIE CHAR,200+"\"
CAIN CHAR,600+"\"
ADDI 0,1
ANDI 0,7 ;MUMBLE
DPSIZ. 0,1
UPGEO: PUSHP N
CALL GEODPY
POPP N
GO LOOP0
ENDR EDTEXT;4-MAY-73(TVR)____________________________________________
SUBR EDSYS,NODE,CHAR ;Invoke system line editor
COMMENT ⊗___________________________________________________________
Here we gronk the system line editor ⊗
ACCUMULATORS{N,C1,C2,P1,P2}
EXTERNAL FILFLG,MACNOD,MACGET
TDZA 0,0 ;Set or clear Q command flag
MOVEI 0,1
DAC 0,FOOFLG
LAC N,NODE ;Put text into EDBUF in preparation
LAC P2,[POINT 7,EDBUF] ;for line edit
MOVEI C2,5*EDBFLN-2
CH1: LAC P1,N ;For each node
HRLI P1,700
MOVEI C1,5*8-1
CHLOOP: ILDB 1,P1 ;Pick up a character
JUMPE 1,CH2 ;Ignore nulls
IDPB 1,P2 ;Put into EDBUF
SOJL C2,[OUTSTR[ASCIZ/Too long for line editor!/] ;Error check
CLRBFI↔SETZ 1,↔POP2J]
CH2: SOJG C1,CHLOOP ;For each character
TESTZ N,CONBIT ;More left?
GO [ TCCW N,N ;Yes
JUMPN N,CH1
GO .+1 ]
MOVEI 1,15 ;Make sure it ends with <return>
IDPB 1,P2
SETZ 0, ;Make sure it terminated with <null>
IDPB 0,P2
PTLOAD [0↔EDBUF] ;Stuff it into line buffer
;Here we should, but don't pick up anything typed ahead
LAC 1,CHAR ;Pick up character starting command
PTWR1W 0 ;Put it into input buffer
LAC 1,CLRLIN+1 ;Turn off line to be editted
PGSEL 17
SKIPE CLRLIN ;Unless we're in Q command
UPGMVM 1,@CLRLIN
MOVEI C1,1 ;Now, how many lines from top
LAC 1,N
CH3: CALL(PRVLIN,1) ;Get previous node
TEST 1,VBIT ;A vertex?
AOJA C1,CH3 ;Yes, try next back
IMULI C1,-30 ;Calculate line position
ADDI C1,=460
PPIOT 6,(C1) ;LAC line editor up there
LAC 1,NODE ;Pick up node
SKIPN FOOFLG ;If Q flag, then pick up display for new line
GO CH4
CALL(INSTXT,NODE) ;Insert a blank line to be filled
DAC 1,NODE ;Save that line
CALL(EDDPY,1,["→"]) ;A line and cursor
CH4: SKIPN FILFLG ;In a macro mode?
SKIPE MACNOD
GO CH5 ;Yes, handle special
TTYUUO 14, ;Wait for activation character
CH6: CALL(SETEXT,NODE,[EDGET]) ;Now
PPIOT 6,0 ;Reset page printer
SETOM EDUPDATE ;Make it know this is an update
LAC 1,BRKCHR ;Get back break character from line edit
POP2J
CH5: CALL(MACGET) ;Get a character from macro
JUMPE 1,CH4 ;If zero, end of macro
SETZ 0, ;Stuff character into input buffer
PTWR1W 0
LAC 0,1 ;Get low order 7 bits
ANDI 0,177
CAIL 0,"a" ;Convert to upper case
CAILE 0,"z"
SKIPA
SUBI 0,40
CAIE 0,12 ;<return> and <line> always terminate
CAIN 0,15
GO CH6
CAIN 0,175 ;As does <alt mode>
GO CH6
CAIL 1,600 ;Always terminate if <control><meta>
GO CH6
CAIL 1,200 ;Not a terminator if no control bits
CAIL 1,400 ;Or <meta>
GO CH5
CAIE 0,"S" ;Must be <control>, test each of edit commands
CAIN 0,"I"
GO CH5
CAIE 0,"D"
CAIN 0,"K"
GO CH5
CAIE 0,11
CAIN 0,40
GO CH5
CAIE 0,14
CAIN 0,177
GO CH5
GO CH6
EDGET: INCHSL 1
POPJ P,
CAIE 1,12
CAIL 1,200
GO [ DAC 1,BRKCHR
GO EDGET ]
CAIN 1,15
GO [ INCHSL 1
JFCL
DAC 1,BRKCHR
POPJ P,]
CAIN 1,175
GO BLAST
AOS (P)
POPJ P,
BLAST: SUB P,[XWD 4,4]
BLAST0: PPIOT 6,0
BLAST1: INCHSL 1
GO BLAST2
CAIE 1,15
GO BLAST1
INCHSL 1
JFCL
BLAST2: LAC P2,[POINT 7,EDBUF]
CALL(SETEXT,NODE,[EDGET2])
SETZ 1,
POP2J
EDGET2: ILDB 1,P2
JUMPE 1,[POPJ P,]
AOS(P)
POPJ P,
DECLARE{BRKCHR,FOOFLG}
ENDR EDSYS;4-MAY-73(TVR)_____________________________________________
SUBR(EDDPY,NODE,CURCHR)
COMMENT ⊗___________________________________________________________⊗
EXTERNAL DPYPTR,RIVECT,DPYBRT
N←4
CALL(DPYSET,DPYBUF)
CALL(DPYBIG,[2])
CALL(DPYBRT,[2])
CALL(AIVECT,[-777],[=460])
CALL(DPYSTR,[[ASCIZ/*****************
/]])
LAC N,NODE
SETZM CURFLG
SKIPA
FNDBEG: TCW N,N
TEST N,VBIT
GO FNDBEG
PTEXT N,N
DPLOOP: SKIPN ENDFLG
CAME N,NODE
GO DP2
CALL(DPYCUR)
DP2: MOVEI 0,1(N)
CALL(DPYSTR,0)
TESTZ N,CONBIT
GO [ TCCW N,N
JUMPN N,DP2
FATAL(MISSING END TO TEXT)]
CALL(DPCRLF)
TCCW N,N
JUMPN N,DPLOOP
DP3: SKIPN ENDFLG
GO DP4
CALL(DPYCUR)
DP4: CALL(DPYSTR,[[ASCIZ/********/]])
CALL(DPCRLF)
CALL(DPYOUT,[17])
POP2J
.PLEVEL←←.PLEVEL+1
DPYCUR: CALL(RIVECT,[-15],[0])
CDR 1,DPYPTR
DAC 1,CLRLIN
SETOM CURFLG
CALL(DTYO,CURCHR)
CALL(DPYSTR,<[[BYTE(7) " ",15,0]]>)
POPJ P,
.PLEVEL←←.PLEVEL-1
DPCRLF: SKIPN CURFLG
GO DPCRL2
SETZM CURFLG
MOVSI 1,000700
HLLM 1,DPYPTR
HRLZ 1,DPYPTR
ADD 1,[XWD 1,20]
DAC 1,CLRLIN+1
DPCRL2: CALL(DPYSTR,[[ASCIZ/
/]])
POPJ P,
DECLARE{CURFLG}
ENDR EDDPY;4-MAY-73(TVR)_____________________________________________
SUBR(INSTXT,NODE)
;Insert a text node in after of NODE. Return new node in 1.
;
;Uses AC 0-1, Transparent to all others
;Calls MKNODE
ACCUMULATORS{NEXT,LAST}
PUSHP NEXT
PUSHP LAST
LAC LAST,NODE
JUMPE LAST,[FATAL(INSTXT called with NIL)]
TESTZ LAST,VBIT
GO L2
L0: TCCW 0,LAST
JUMPE 0,L2
LAC LAST,0
TESTZ LAST,CONBIT
GO L0
L2: CALL(MKNODE↑,[$TEXT]) ;Make a new text node
TESTZ LAST,VBIT ;Are we inserting at beginning of text list?
GO [ PTEXT NEXT,LAST ;Yes, special pointers
PTEXT. 1,LAST
GO L1 ]
TCCW NEXT,LAST ;Get next node
TCCW. 1,LAST ;Make new forward link
L1: TCCW. NEXT,1
TCW. LAST,1 ;Make new backward links
SKIPE NEXT↔TCW. 1,NEXT ;Don't store into NIL
POPP LAST
POPP NEXT
POP1J
ENDR INSTXT;4-MAY-73(TVR)____________________________________________
SUBR(NXTLIN,NODE)
COMMENT ⊗___________________________________________________________
Return pointer to next line, 0 if last line. Uses AC 0-1.⊗
LAC 1,NODE ;Fetch node
TESTZ 1,VBIT ;Is it a vertex?
GO [ PTEXT 1,1 ;Yes, Next is alway the PTEXT link
POP1J ]
LOOP1: TESTZ 1,CONBIT ;Is node at end of line?
GO [ TCCW 1,1 ;No, get another and try again
GO LOOP1 ]
TCCW 1,1 ;Now the next character will be a new line
POP1J ;Return
ENDR NXTLIN;6-MAY-73(TVR)____________________________________________
SUBR(PRVLIN,NODE)
;Returns pointer to previous line or vertex if called with first line
;
;Uses AC 0-1
;
LAC 1,NODE ;Fetch node
TESTZ 1,VBIT ;Lose if at vertex
GO [ FATAL(PRVLIN called with VERTEX) ]
TCW 1,1 ;Get previous node
TESTZ 1,VBIT ;Is it the vertex?
POP1J ;Yes, return in
LOOP: TCW 1,1 ;Find end of previous line
TESTZ 1,VBIT ;Is it a line
GO [ PTEXT 1,1 ;No, the line starts thru PTEXT link
POP1J ]
TLNE 0,(CONBIT) ;Is it an end of line?
GO LOOP ;No, try next one back
TCCW 1,1 ;Now, go forward one and that's the line
POP1J ;Now, if the first node instead of the last
;were noted, this would be alot easier!
ENDR PRVLIN;6-MAY-73(TVR)____________________________________________
SUBR(YDPY,NODE)
COMMENT ⊗------------------------------------------------------------
⊗↔ T←15 ↔ SIZ←14
LAC 1,NODE↔TESTZ 1,NSEW+TBIT1 ;IF INVISIBLE, THEN SKIP THIS ONE
POP1J↔PY T,1 ;GET TJOINT OR TEXT OF VERTEX
JUMPE T,POP1J.↔DAC T,NODE ;NOTHING THERE
LAC 0,(T)↔ANDI 0,17
CAIE 0,$YNODE↔POP1J ;IF IT'S A TJOINT, LEAVE
MARK 1,TBIT1 ;REMEMBER WE'VE BEEN HERE
GO YDPY1
YDPY2: LAC T,NODE↔PY T,T↔JUMPE T,POP1J.
YDPY1: DAC T,NODE↔YCODE 1,T
CAIN 1,$TEXTHD↔GO DPYTXT
CAIN 1,$ARROW↔GO[CALL DPYARW,T↔GO YDPY2]
FATAL(ILLEGAL YNODE FOUND)
DPYTXT: ;FETCH COORDINATES.
DPSIZ SIZ,T
XDC 0,T↔FIXX 0,↔NIP 1,CHROFF(SIZ)↔SKIPN PLTFLG↔ADD 0,1↔DAC 0,TX
YDC 0,T↔FIXX 0,↔NAP 1,CHROFF(SIZ)↔SKIPN PLTFLG↔ADD 0,1↔DAC 0,TY
PTEXT T,T↔SKIPN SIZ↔LACI SIZ,1
CALL(DPYBRT,[1])↔CALL(DPYBIG,SIZ)↔LAC 0,TY
DPYTX2: CAMGE 0,YH↔CAMGE 0,YL↔GO DPYTX3 ;MAKE SURE IT'S WITHIN WINDOW
CALL(AIVECT,TX,TY) ;POSITION IT
DPYTX4: MOVEI 0,1(T)
CALL(DPYSTR,0) ;DISPLAY IT (THIS MAY OVERFLOW WEST)
TESTZ T,CONBIT ;IS IT CONTINUED?
GO [ TCCW T,T ;YES, GET NEXT LINE
JUMPN T,DPYTX4 ;MAKE SURE THERE'S SOMETHING THERE
FATAL<Missing continuation of text node.> ]
DPYTX3: TCCW T,T↔JUMPE T,YDPY2 ;GET NEXT TEXT NODE (OR E.O.L).
; HRREI 0,-20 ;THIS REALLY SHOULD BE SIZE DEPENDENT
HRRZ 0,CHRSIZ(SIZ)
MOVN↔ADDB 0,TY ;INCREMENT
GO DPYTX2
ENDR YDPY;-----------------------------------------------------------
CHRSIZ: 20 ;0 (SAME AS 2)
20 ;1
30 ;2
34 ;3
40 ;4
60 ;5
100 ;6
140 ;7
CHROFF: XWD =-9,=-9 ;0 (SAME AS 2)
XWD =-8,=-7 ;1
XWD =-9,=-9 ;2
XWD =-9,=-11 ;3
XWD =-8,=-13 ;4
XWD =-9,=-16 ;5
XWD =-10,=-21 ;6
XWD =-11,=-25 ;7
SUBR(DPYARW,NODE)
;Display an arrow
ACCUMULATORS{FLG,T1,N,V1,V2,DX1,DY1,DX2,DY2,X1,Y1}
ARWSIZ←←1
;Decide whether to make arrow this time
LAC N,NODE ;FETCH NODE IN QUESTION
TESTZ N,NSEW↔POP1J ;MAKE SURE IT'S NOT OFF SCREEN
TEST N,TBIT1↔POP1J ;HAVEN'T WE BEEN HERE BEFORE...
PARRW V2,N ;AND THE OTHER END
MARKZ N,TBIT1 ;SO WE WOULD COME THRU TWICE WITH SAME VERTEX
TESTZ V2,TBIT1 ;HAVE WE BEEN HERE YET?
POP1J ;NO, RETURN AND TRY AGAIN
;Check for off screen
TESTZ V2,NSEW↔POP1J ;CHECK FOR OFF SCREEN
PVT V2,V2 ;NOW GET SECOND VERTEX
TESTZ V2,NSEW↔POP1J ;CHECK FOR OFF SCREEN
PVT V1,N ;AND LASTLY THE FIRST VERTEX
TESTZ V1,NSEW↔POP1J ;CHECK FOR OFF SCREEN
LAC 0,XWC(V2) ;Calculate distance between points
FSBR 0,XWC(V1)
FMPR 0,0
LAC 1,YWC(V2)
FSBR 1,YWC(V1)
FMPR 1,1
FADR 0,1
LAC 1,ZWC(V2)
FSBR 1,ZWC(V1)
FMPR 1,1
FADR 0,1
CALL SQRT,0
MOVE X1,[POINT 7,ARWBLK] ;Convert to character stream
SETZ Y1,
CALL(WRFLO,0,<[JSP DY2,[IDPB 1,X1↔AOJA Y1,(DY2)]]>)
DAC Y1,CHRCNT
SETZ 1,
IDPB 1,X1
;Calculate extention, etc.
XDC DX1,V2 ;Fetch coordinates of V2
YDC DY1,V2
XDC DX2,N ;Fetch coordinates of V1'
YDC DY2,N
XDC 0,V1 ;Fetch coordinates of V1
YDC 1,V1 ; -→
FSBR DX1,0 ;Calculate E1
FSBR DY1,1 ; -→
FSBR DX2,0 ;Calculate E2
FSBR DY2,1 ; -→
FSC DX1,-1 ;Divide E1 by 2.0
FSC DY1,-1
FADR 0,DX1 ;This is the bisector of V1' and V2'
FADR 1,DY1
FADR 0,DX2
FADR 1,DY2
DAC 0,XCEN ;Save somewhere
DAC 1,YCEN
LAC 0,DX1 ;Normalize
LAC 1,DY1
CALL DIST
FDVR DX1,1
FDVR DY1,1
LAC 0,DX2 ;Normalize
LAC 1,DY2
CALL DIST
FDVR DX2,1
FDVR DY2,1
MOVN 0,DX2
MOVN 1,DY2
FMPR 0,K4
FMPR 1,K4
FADRM 0,XCEN
FADRM 1,YCEN
CALL(DPYBIG,[ARWSIZ])
MOVN X1,CHRCNT ;Calculate center of arrow
IMUL X1,CHRSIZ+ARWSIZ
FSC X1,231 ;(Float and divide by 4)
DACM X1,XOFFSET
FADR X1,XCEN
MOVN Y1,CHRSIZ+ARWSIZ
FSC Y1,232 ;(Float and divide by 2)
FADR Y1,YCEN
CAR 0,CHROFF+ARWSIZ ;Correct for losing III!
FSC 0,233
SKIPN PLTFLG
FADR X1,0
CDR 0,CHROFF+ARWSIZ
FSC 0,233
SKIPN PLTFLG
FADR Y1,0
CALL FAI
CALL(DPYSTR,[ARWBLK])
LAC 0,DX1
LAC 1,DY1
CALL DIST
LAC 1,CHRSIZ+ARWSIZ
FSC 1,232 ;(Float and divide by 2)
FDVRB 1,0
FMPR 0,DX1
FDVR 0,DY1
LACM 0,0
CAMGE 0,1
LAC 0,1
CAMLE 0,XOFFSET
LAC 0,XOFFSET
LAC 1,CHRSIZ+ARWSIZ
FSC 1,232 ;(Float and divide by 2)
FADR 0,1
DAC 0,K3
CALL HALF ;Do first half of arrow
MOVN DX1,DX1 ; -→
MOVN DY1,DY1 ;XChange sign of E1
EXCH V1,V2 ;Switch vertices
PARRW N,N ;And Ynodes
XDC DX2,N ;Fetch coordinates of V1'
YDC DY2,N
XDC 0,V1 ;Fetch coordinates of V1
YDC 1,V1 ; -→
FSBR DX2,0 ;Calculate E2
FSBR DY2,1 ; -→
LAC 0,DX2 ;Normalize
LAC 1,DY2
CALL DIST
FDVR DX2,1
FDVR DY2,1
CALL HALF
POP1J
;---- DPYARW continued.
DIST: FMPR 0,0 ;Calculate length of vector
FMPR 1,1
FADR 1,0
CALL SQRT↑,1
POP0J
HALF: LAC X1,V1 ;Draw extension
LACI Y1,DX2
LAC 0,K5
CALL OFFAI
LAC X1,N
SETZ 0,
CALL OFFAV
LAC X1,N ;Upper wing of arrow
LACI Y1,DX2
MOVN 0,K4
CALL OFFAI
PUSHP X1 ;Save start of arrow
PUSHP Y1
LAC 0,DX1
LAC 1,DY1
FMPR 0,K1
FMPR 1,K1
LAC X1,DX2
LAC Y1,DY2
FMPR X1,K2
FMPR Y1,K2
FADR 0,X1
FADR 1,Y1
FIX 0,233000
FIX 1,233000
CALL RVECT,0,1
MOVN 0,X1 ;Now the lower wing
MOVN 1,Y1
FIX 0,232000 ;(Doubles)
FIX 1,232000
CALL RIVECT,0,1
CALL AVECT ;(With arguments saved above)
MOVN X1,DX1 ;The main line of arrow
MOVN Y1,DY1
FMPR X1,K3
FMPR Y1,K3
FADR X1,XCEN
FADR Y1,YCEN
FAV: SETO FLG
GO FVECT
FAI: SETZ FLG,
GO FVECT
OFFAI: TDZA FLG,FLG
OFFAV: SETO FLG,
LAC 1,0
JUMPE 0,.+3
FMPR 0,(Y1)
FMPR 1,1(Y1)
YDC Y1,X1
XDC X1,X1
FADR X1,0
FADR Y1,1
FVECT: FIX X1,233000
FIX Y1,233000
JUMPE FLG,[CALL AIVECT,X1,Y1
POP0J]
CALL AVECT↑,X1,Y1
POP0J
DECLARE{XCEN,YCEN,CHRCNT,XOFFSET}
ARWBLK: BLOCK 10
;ARROW PARAMETERS:
COMMENT $
----- ⊗
↑ | |
| -→| K1 |←-
| | |____
K4 | / ↑
| | / | | |
| | / K2 |←- K3 -→|
↓ | / | | |
----- |/______↓________________________ .
-→|\ (Center of dimension)
E2| \
| \
| | \
↓ |
--- | -→
K5 E1
--- ⊗____________________________________________________________
↑
|
-→ -→
E1 = (DX1,DY1) E2 = (DX2,DY2)
$;
K1: 20.0
K2: 7.0
;K3: 20.0
DECLARE{K3} ;Set according to size of text
K4: 10.0
K5: 4.0
ENDR DPYARW
SUBR(EXTARW,NODE,CAMERA)
ACCUMULATORS{N,T1,T2,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3}
LAC N,NODE
TESTZ N,TBIT1↔POP2J
LDB 0,[POINT 3,(N),12] ;Get type of extension
CAILE 0,3 ;If less than 3 then get face coefficients
GO NOFACE
TRNN 0,1 ;Is PFACE involved?
GO NOTPFA
YPF 0,N ;Face coefficients for PFACE
CALL(FACOEF,0,[0])
LAC N,NODE
LDB 0,[POINT 3,(N),12] ;Get type of extension
TRNN 0,2 ;Is NFACE involved?
GO NOFACE
NOTPFA: YNF 0,N ;Face coefficients for NFACE
CALL(FACOEF,0,[0])
LAC N,NODE
NOFACE: PVT T1,N ;Pointer to first vertex in T1
PARRW 1,N↔PVT T2,1 ;Pointer to second vertex - T2
MARK N,TBIT1
MARK 1,TBIT1
FOR @` I ε {XYZ} ;Fetch second vertex coordinates.
< LAC I`1,I`WC(T2)
> ; -→
FOR @` I ε {XYZ} ;Subtract the first to get E1
< FSBR I`1,I`WC(T1)
>
LDB T1,[POINT 3,(N),12] ;Get type of extension
XCT [ ;Fetch appropriate face
GO [ ILGEXT: FATAL(ILLEGAL EXTENSION TYPE) ]
YPF T2,N
YNF T2,N
YPF T2,N
LACI T2,[1.0↔ 0 ↔ 0 ]+3
LACI T2,[ 0 ↔1.0↔ 0 ]+3
LACI T2,[ 0 ↔ 0 ↔1.0]+3
GO ILGEXT ](T1) ; -→
LAC X2,AA(T2) ;Copy normal into E2
LAC Y2,BB(T2)
LAC Z2,CC(T2)
CAIE T1,3 ;Is type 3?
GO L2 ;No
YNF T2,N ;Yes, make bisector of dihedral angle
CAMN X2,AA(T2) ;Zero check!
GO [ CAMN Y2,BB(T2)
CAME Z2,CC(T2)
GO .+1
GO L2 ]
FSBR X2,AA(T2)
FSBR Y2,BB(T2)
FSBR Z2,CC(T2) ; -→ -→ -→ -→ -→
L2: DEFINE CROSS `(X,Y,Z) ;The extension, E3 = E1 x NF (NF is in E2)
< LAC X`3,Y`1
LAC T1,Z`1
FMPR X`3,Z`2
FMPR T1,Y`2
FSBR X`3,T1
>
CROSS X,Y,Z
CROSS Y,Z,X
CROSS Z,X,Y
;---- EXTARW continued.
CALL EXTONE ;Calculate world co-ordinates for each
PARRW N,N
CALL EXTONE
CALL APROJ,N,CAMERA ;Run each thru projector
CALL MAKDPY
PARRW N,N
CALL APROJ,N,CAMERA
CALL MAKDPY
POP2J
;EXTEND ONE VERTEX
EXTONE: PVT T1,N
FOR @` I ε {XYZ} ; -→
< LAC I`1,I`3 ;Copy E3
FADR I`1,I`WC(T1) ;Add to V1
DAC I`1,I`PP(N) ;Store into V1' (into incorrect place!)
>
POP0J
;COMPUTE DISPLAY COORDINATES OF THE VERTEX.
MAKDPY: PVT T1,N ;Fetch vertex
FOR @` I ε {XYZ}
< LAC I`1,I`PP(N)↔FSBR I`1,I`PP(T1)
>
LAC 0,X1↔FMPR 0,0↔LAC 1,Y1↔FMPR 1,1↔FADR 0,1
CALL SQRT,0↔LAC 0,OFFSET(N)↔FDVR 0,1
FOR @` I ε {XYZ}
< FMPR I`1,0↔FADR I`1,I`PP(T1)↔DAC I`1,I`PP(N)
>
LAC 0,XPP(N)↔FMPR 0,MAG↔FADR 0,SOX↔XDC. 0,N
LAC 0,YPP(N)↔FMPR 0,MAG↔FADR 0,SOY↔YDC. 0,N
POP0J
;Arrow Extension Mandala
COMMENT $
The dimensioning in GEOMED is done semi-automatically, by the the
command αA. It positions the arrow in terms of the offset from the
two points and a face which determines the direction of the
extension lines. This direction is calculated as follows.
V1' V2'
⊗-----------------------⊗
| |
|-→ |
|E2 -→ |
| E1 |
V1⊗-----------------------⊗V2
| __ \
| -→ /| \
| NF / \
| F1 / \
| / \
| ⊗ \
| \
⊗-------------------------------⊗
The face, F1 is defined as Ax+By+Cz+K=0
-→
The normal to F1 is: NF = (A,B,C)
-→
The endpoint of the extension, V1' is to be perpendicular to edge E1
defined by the two points, V1 and V2, and parallel to the face F1.
V1' may be defined as
-→ -→ -→ -→
V1' = V1 + k E2 where E2 = E1 X NF
-→
and similarly V2' = V2 + k E2.
The constant, k, is chosen automatically according to the distance
from the camera and focal length.
$;
ENDR EXTARW;6-JUN-D73(TVR)
SUBR(APROJ,VERTEX,CAMERA) ;TRANSLATE VERTEX TO CAMERA LOCUS.
COMMENT ⊗------------------------------------------------------------
⊗↔ ACCUMULATORS{B,F,E,V,CAM,E0,X,XX,Y,YY,Z,ZZ,FRM}
LAC CAM,CAMERA
FRAME FRM,CAM
LAC V,VERTEX
LAC X,XPP(V)↔FSBR X,XWC(FRM)
LAC Y,YPP(V)↔FSBR Y,YWC(FRM)
LAC Z,ZPP(V)↔FSBR Z,ZWC(FRM)
;ROTATE TO CAMERA ORIENTATION.
LAC XX,X↔FMPR XX,IX(FRM)
LAC Y↔FMPR IY(FRM)↔FADR XX,
LAC Z↔FMPR IZ(FRM)↔FADR XX,
LAC YY,X↔FMPR YY,JX(FRM)
LAC Y↔FMPR JY(FRM)↔FADR YY,
LAC Z↔FMPR JZ(FRM)↔FADR YY,
LAC ZZ,X↔FMPR ZZ,KX(FRM)
LAC Y↔FMPR KY(FRM)↔FADR ZZ,
LAC Z↔FMPR KZ(FRM)↔FADR ZZ,
;PERSPECTIVE TRANSFORMATION.
TESTZ CAM,NOTPER↔MOVSI ZZ,(<-16.0>)
FMPR XX,-3(CAM)↔FDVR XX,ZZ↔DAC XX,XPP(V)
FMPR YY,-2(CAM)↔FDVR YY,ZZ↔DAC YY,YPP(V)
MOVN Z, 3(CAM)↔FSC Z,=17
FDVR Z,ZZ↔DAC Z,ZPP(V)
POP2J
ENDR APROJ;(BGB)-----------------------------------------------------
CLRLIN: BLOCK 2
EDBUF: BLOCK =21
EDBFLN←←.-EDBUF
DECLARE{EDUPDATE,ENDFLG}
;Subroutines WREFLO,WRFFLO,WRFLO
;____________________________________________________________________
SUBR(WREFLO,NUMBER,CONTRL,OPERATION)
ACCUMULATORS{DECPT,DECEXP,CHRCNT}
;DECPT Number of characters remaining before decimal point
;DECEXP Exponent (Decimal)
;CHRCNT Total number of characters remaining
;
JSP 0,FLONRM ;SET UP AC'S AND NORMALIZE FOR BASE 10
.PLEVEL←←.PLEVEL+3
CAMG CHRCNT,DECEXP ;WILL IT FIT?
GO ELOST ;LOSES!
SKIPL DECEXP ;IF EXP≥0
SUB DECPT,DECEXP ; THEN SUBTRACT SPACE FOR FIXED PART + DEC. PT
HLRZ 1,CONTRL ;FETCH NUMBER OF DIGITS RIGHT OF DEC. PT.
CAILE DECPT,1(1) ;IS THERE MORE ROOM THAN SPECIFIED?
MOVEI DECPT,1(1) ;YES, USE SPECIFIED DECIMAL POINT
SUBM CHRCNT,DECPT ;SUBTRACT CHARACTER RIGHT OF DEC. PT. FROM CHAR. COUNT
CALL FLOUT ;TO GET COUNT LEFT OF DEC. PT. AND CALL OUTPUT ROUTINE
GO FLORET
;+X.XXXE+YY
↑WRFFLO↑:JSP 0,FLONRM ;SET UP AC'S AND NORMALIZE FOR BASE 10
CALL FLONRM ;MAKE A DECIMAL EXPONENT AND NORMALIZE
ELOST: SKIPL NUMBER
GO [ MOVEI 1,"+" ;'+' FOR 'F' FORMAT
XCT OPCODE
SOJA CHRCNT,.+1 ]
SUBI CHRCNT,4 ;SUBTRACT SPACE FOR EXPONENT
JUMPLE CHRCNT,FLOST ;LOSE CASE
PUSHP DECEXP
MOVEI DECPT,1
MOVEI DECEXP,1
CALL FLOUT ;OUTPUT MANTISSA
POPP DECEXP
MOVEI 1,"E"
XCT OPCODE
JUMPL DECEXP,[MOVN DECEXP,DECEXP ;OUTPUT EXPONENT
MOVEI 1,"-"
GO .+2]
MOVEI 1,"+"
XCT OPCODE
IDIVI DECEXP,=10
MOVEI 1,"0"(DECEXP)
XCT OPCODE
MOVEI 1,"0"(DECEXP+1)
XCT OPCODE
GO FLORET
FLOST: ADDI CHRCNT,4
MOVEI 1,"*"
FLOST1: SOJLE CHRCNT,FLORET
XCT OPCODE
GO FLOST1
.PLEVEL←←.PLEVEL-3
;NSUBR WRFLO,NUMBER,OPERATION
↑WRFLO↑:PUSH P,(P) ;COPY RETURN ADDRESS
MOVE 0,-2(P) ;REPLACE ORIGINAL WITH OPERATION
MOVEM 0,OPERATION
MOVEI 0,1+7+1+4 ;(SIGN+MANTISSA+DEC.PT.+EXPONENT)
MOVEM 0,CONTRL
JSP 0,FLONRM ;SET UP AC'S AND NORMALIZE FOR BASE 10
CAMLE DECEXP,[-4]
CAIL DECEXP,7
GO ELOST
JUMPE 0,[MOVEI 1,"0"
XCT OPCODE
GO FLORET]
PUSH P,[WRFLO2] ;FAKE RETURN ADDRESS!
ADDI DECEXP,1 ;MAKES LIFE EASIER
MOVEI DECPT,7 ;SO THAT DECIMAL POINT IS NOT PRINTED IF NO
;FRACTIONAL PART!
WRFLO3: JUMPG DECEXP,WRFLO4
MOVEI 1,"0"
XCT OPCODE
MOVEI 1,"."
XCT OPCODE
MOVEI 1,"0"
AOJLE DECEXP,.-2
SUBI DECEXP,1 ;SIGH...
WRFLO4: IDIVI 0,=10
SUBI DECPT,1
JUMPE 1,WRFLO4
GO .+2
WRFLO1: IDIVI 0,=10 ;CLASSIC RECURSIVE DECIMAL PRINTER
HRLM 1,(P) ;(LEFT HALF OF RETURN ADDRESS)
JUMPE 0,.+2
CALL WRFLO1
HLRZ 1,(P) ;FETCH CHARACTER FROM LEFT HALF OF RETURN ADDRESS
ADDI 1,"0" ;CONVERT TO DECIMAL FOR OUTPUT
XCT OPCODE
SUBI DECPT,1
SOJN DECEXP,CPOPJ ;RETURN (TO NEXT CHARACTER OR DRIVER) IF CHAR. LEFT OF DEC. PT. ≠ 0.
JUMPL DECPT,CPOPJ ;NO DECIMAL POINT IF NO FRACTIONAL PART!
MOVEI 1,"." ;OUTPUT DECIMAL POINT
XCT OPCODE
POPJ P,
WRFLO2: MOVEI 1,"0"
SOJL DECEXP,FLORET
XCT OPCODE
GO .-2
; FLOATING POINT NORMALIZE (FOR BASE 10).
; Call with JSP 0,FLINIT
FLONRM: PUSHP DECPT ;SAVE AC'S
PUSHP DECEXP
PUSHP CHRCNT
PUSHP 0 ;SAVE RETURN ADDRESS
MOVE 0,OPERATION
MOVEM 0,OPCODE
MOVE 0,NUMBER ;SET UP AC WITH NUMBER TO BE PRINTED
HRRZ CHRCNT,CONTRL ;FETCH NUMBER OF CHARACTERS FOR OUTPUT
JUMPG 0,FLONR2 ;NEGATIVE NUMBER?
MOVNS 0 ;NEGATE NUMBER
MOVEI 1,"-" ;OUTPUT A "-"
FLONR1: XCT OPCODE
SUBI CHRCNT,1
FLONR2: JUMPE 0,[SETZ DECEXP,↔POPJ P,] ;TEST FOR ZERO
MOVEI DECEXP,6 ;INIT. EXPONENT
TLNN 0,377000 ;IS IT FLOATING?
FSC 0,233 ;NO! FLOAT IT!
FLONR3: CAML 0,[999999.5] ;NORMALIZE
JRST FLONR4
FMPR 0,[10.0]
SOJA DECEXP,FLONR3
FLONR4: CAMGE 0,[9999999.5]
JRST .+3
FDVR 0,[10.0]
AOJA DECEXP,FLONR4
FIX 0,232000 ;FIX to 2*n
ADDI 0,1 ;Round it
ASH 0,-1
HRRZ DECPT,CHRCNT ;ALSO INTO CHRCNT
MOVEM CHRCNT,WIDTH ;(REMEMBER FOR DECIMAL POINT)
POP0J
.PLEVEL←←.PLEVEL-1
;____________________________________________________________________
FLORET: POPP CHRCNT ;RESTORE AC'S
POPP DECEXP
POPP DECPT
POP3J
;____________________________________________________________________
;OUTPUT FLOATING POINT NUMBER IN SPECIFIED FORMAT
FLOUT: MOVEI 1," " ;START WITH LEADING SPACES, UNTIL DEC. PT.
ADDI DECEXP,1 ;THIS SAVES TIME LATER!
FLOUT1: CAMG DECPT,DECEXP ;LEADING SPACES/ZEROS?
GO FLOUT3 ;NO, START ACTUAL INFORMATION
SOJE DECPT,[ MOVEI 1,"0" ;IF CHARACTERS LEFT OF DEC. PT = 0, PRINT "0."
XCT OPCODE
SOJLE CHRCNT,CPOPJ ;CHECK IF DONE WITH FIELD
MOVEI 1,"."
XCT OPCODE
MOVEI 1,"0" ;USE ZEROS FROM NOW ON
GO FLOUT2 ]
XCT OPCODE ;OUTPUT SPACE OR ZERO
FLOUT2: SOJLE CHRCNT,CPOPJ ;CHECK FOR END OF FIELD
GO FLOUT1 ;REPEAT UNTIL ACTUAL INFORMATION STARTS.
;START ACTUAL INFORMATION
FLOUT3: JUMPLE DECEXP,.+3 ;IS DEC. PT. TO BE INCLUDED IN COUNT?
CAME DECEXP,WIDTH
SUBI CHRCNT,1 ;YES, ACCOUNT FOR IT
CAIG CHRCNT,6
IDIV DECTAB-1(CHRCNT)
CALL FLOUT4
MOVEI 1,"0"
FLOUT5: SOJL CHRCNT,CPOPJ ;TRAILING ZEROS
XCT OPCODE
SOJE DECPT,[MOVEI 1,"."
CAME DECEXP,WIDTH ;SPECIAL CASE CHECK
XCT OPCODE
JUMPE CHRCNT,CPOPJ
GO FLOUT5-1]
GO FLOUT5
FLOUT4: IDIVI 0,=10 ;CLASSIC RECURSIVE DECIMAL PRINTER
HRLM 1,(P) ;(LEFT HALF OF RETURN ADDRESS)
SOJLE CHRCNT,.+3 ;END OF FIELD CHECK
JUMPE 0,.+2
CALL FLOUT4
HLRZ 1,(P) ;FETCH CHARACTER FROM LEFT HALF OF RETURN ADDRESS
ADDI 1,"0" ;CONVERT TO DECIMAL FOR OUTPUT
XCT OPCODE
SOJN DECPT,CPOPJ ;RETURN (TO NEXT CHARACTER OR DRIVER) IF CHAR. LEFT OF DEC. PT. ≠ 0.
MOVEI 1,"." ;OUTPUT DECIMAL POINT
XCT OPCODE
CPOPJ: POPJ P,
;____________________________________________________________________
DECTAB: =1000000↔=100000↔=10000↔=1000↔=100↔=10
DECLARE{OPCODE,WIDTH}
ENDR WREFLO
END